home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / scripts / read-scheme-source < prev    next >
Encoding:
Text File  |  2004-01-06  |  11.8 KB  |  285 lines
  1. #!/bin/sh
  2. # aside from this initial boilerplate, this is actually -*- scheme -*- code
  3. main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')'
  4. exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
  5. !#
  6. ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
  7.  
  8. ;;     Copyright (C) 2001 Free Software Foundation, Inc.
  9. ;;
  10. ;; This program is free software; you can redistribute it and/or
  11. ;; modify it under the terms of the GNU General Public License as
  12. ;; published by the Free Software Foundation; either version 2, or
  13. ;; (at your option) any later version.
  14. ;;
  15. ;; This program is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19. ;;
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with this software; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  23. ;; Boston, MA 02111-1307 USA
  24.  
  25. ;;; Author: Thien-Thi Nguyen
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; Usage: read-scheme-source FILE1 FILE2 ...
  30. ;;
  31. ;; This program parses each FILE and writes to stdout sexps that describe the
  32. ;; top-level structures of the file: scheme forms, single-line comments, and
  33. ;; hash-bang comments.  You can further process these (to associate comments
  34. ;; w/ scheme forms as a kind of documentation, for example).
  35. ;;
  36. ;; The output sexps have one of these forms:
  37. ;;
  38. ;;    (quote (filename FILENAME))
  39. ;;
  40. ;;    (quote (comment :leading-semicolons N
  41. ;;                    :text LINE))
  42. ;;
  43. ;;    (quote (whitespace :text LINE))
  44. ;;
  45. ;;    (quote (hash-bang-comment :line LINUM
  46. ;;                              :line-count N
  47. ;;                              :text-list (LINE1 LINE2 ...)))
  48. ;;
  49. ;;    (quote (following-form-properties :line LINUM
  50. ;;                                      :line-count N)
  51. ;;                                      :type TYPE
  52. ;;                                      :signature SIGNATURE
  53. ;;                                      :std-int-doc DOCSTRING))
  54. ;;
  55. ;;    SEXP
  56. ;;
  57. ;; The first four are straightforward (both FILENAME and LINE are strings sans
  58. ;; newline, while LINUM and N are integers).  The last two always go together,
  59. ;; in that order.  SEXP is scheme code processed only by `read' and then
  60. ;; `write'.
  61. ;;
  62. ;; The :type field may be omitted if the form is not recognized.  Otherwise,
  63. ;; TYPE may be one of: procedure, alias, define-module, variable.
  64. ;;
  65. ;; The :signature field may be omitted if the form is not a procedure.
  66. ;; Otherwise, SIGNATURE is a list showing the procedure's signature.
  67. ;;
  68. ;; If the type is `procedure' and the form has a standard internal docstring
  69. ;; (first body form a string), that is extracted in full -- including any
  70. ;; embedded newlines -- and recorded by field :std-int-doc.
  71. ;;
  72. ;;
  73. ;; Usage from a program: The output list of sexps can be retrieved by scheme
  74. ;; programs w/o having to capture stdout, like so:
  75. ;;
  76. ;;    (use-modules (scripts read-scheme-source))
  77. ;;    (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
  78. ;;
  79. ;; There are also two convenience procs exported for use by Scheme programs:
  80. ;;
  81. ;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
  82. ;;                   have the same number of leading semicolons.
  83. ;;
  84. ;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
  85. ;;                        the ":tags", and return alist of (TAG . VAL) elems.
  86. ;;
  87. ;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
  88. ;;       Make `annotate!' extensible.
  89.  
  90. ;;; Code:
  91.  
  92. (define-module (scripts read-scheme-source)
  93.   :use-module (ice-9 rdelim)
  94.   :export (read-scheme-source
  95.            read-scheme-source-silently
  96.            quoted?
  97.            clump))
  98.  
  99. ;; Try to figure out what FORM is and its various attributes.
  100. ;; Call proc NOTE! with key (a symbol) and value.
  101. ;;
  102. (define (annotate! form note!)
  103.   (cond ((and (list? form)
  104.               (< 2 (length form))
  105.               (eq? 'define (car form))
  106.               (pair? (cadr form))
  107.               (symbol? (caadr form)))
  108.          (note! ':type 'procedure)
  109.          (note! ':signature (cadr form))
  110.          (and (< 3 (length form))
  111.               (string? (caddr form))
  112.               (note! ':std-int-doc (caddr form))))
  113.         ((and (list? form)
  114.               (< 2 (length form))
  115.               (eq? 'define (car form))
  116.               (symbol? (cadr form))
  117.               (list? (caddr form))
  118.               (< 3 (length (caddr form)))
  119.               (eq? 'lambda (car (caddr form)))
  120.               (string? (caddr (caddr form))))
  121.          (note! ':type 'procedure)
  122.          (note! ':signature (cons (cadr form) (cadr (caddr form))))
  123.          (note! ':std-int-doc (caddr (caddr form))))
  124.         ((and (list? form)
  125.               (= 3 (length form))
  126.               (eq? 'define (car form))
  127.               (symbol? (cadr form))
  128.               (symbol? (caddr form)))
  129.          (note! ':type 'alias))
  130.         ((and (list? form)
  131.               (eq? 'define-module (car form)))
  132.          (note! ':type 'define-module))
  133.         ;; Add other types here.
  134.         (else (note! ':type 'variable))))
  135.  
  136. ;; Process FILE, calling NB! on parsed top-level elements.
  137. ;; Recognized: #!-!# and regular comments in addition to normal forms.
  138. ;;
  139. (define (process file nb!)
  140.   (nb! `'(filename ,file))
  141.   (let ((hash-bang-rx (make-regexp "^#!"))
  142.         (bang-hash-rx (make-regexp "^!#"))
  143.         (all-comment-rx (make-regexp "^[ \t]*(;+)"))
  144.         (all-whitespace-rx (make-regexp "^[ \t]*$"))
  145.         (p (open-input-file file)))
  146.     (let loop ((n (1+ (port-line p))) (line (read-line p)))
  147.       (or (not n)
  148.           (eof-object? line)
  149.           (begin
  150.             (cond ((regexp-exec hash-bang-rx line)
  151.                    (let loop ((line (read-line p))
  152.                               (text (list line)))
  153.                      (if (or (eof-object? line)
  154.                              (regexp-exec bang-hash-rx line))
  155.                          (nb! `'(hash-bang-comment
  156.                                  :line ,n
  157.                                  :line-count ,(1+ (length text))
  158.                                  :text-list ,(reverse
  159.                                               (cons line text))))
  160.                          (loop (read-line p)
  161.                                (cons line text)))))
  162.                   ((regexp-exec all-whitespace-rx line)
  163.                    (nb! `'(whitespace :text ,line)))
  164.                   ((regexp-exec all-comment-rx line)
  165.                    => (lambda (m)
  166.                         (nb! `'(comment
  167.                                 :leading-semicolons
  168.                                 ,(let ((m1 (vector-ref m 1)))
  169.                                    (- (cdr m1) (car m1)))
  170.                                 :text ,line))))
  171.                   (else
  172.                    (unread-string line p)
  173.                    (let* ((form (read p))
  174.                           (count (- (port-line p) n))
  175.                           (props (let* ((props '())
  176.                                         (prop+ (lambda args
  177.                                                  (set! props
  178.                                                        (append props args)))))
  179.                                    (annotate! form prop+)
  180.                                    props)))
  181.                      (or (= count 1)    ; ugh
  182.                          (begin
  183.                            (read-line p)
  184.                            (set! count (1+ count))))
  185.                      (nb! `'(following-form-properties
  186.                              :line ,n
  187.                              :line-count ,count
  188.                              ,@props))
  189.                      (nb! form))))
  190.             (loop (1+ (port-line p)) (read-line p)))))))
  191.  
  192. ;;; entry points
  193.  
  194. (define (read-scheme-source-silently . files)
  195.   "See commentary in module (scripts read-scheme-source)."
  196.   (let* ((res '()))
  197.     (for-each (lambda (file)
  198.                 (process file (lambda (e) (set! res (cons e res)))))
  199.               files)
  200.     (reverse res)))
  201.  
  202. (define (read-scheme-source . files)
  203.   "See commentary in module (scripts read-scheme-source)."
  204.   (for-each (lambda (file)
  205.               (process file (lambda (e) (write e) (newline))))
  206.             files))
  207.  
  208. ;; Recognize:          (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
  209. ;; and return alist:   ((TAG1 . VAL1) (TAG2 . VAL2) ...)
  210. ;; where the tags are symbols.
  211. ;;
  212. (define (quoted? sym form)
  213.   (and (list? form)
  214.        (= 2 (length form))
  215.        (eq? 'quote (car form))
  216.        (let ((inside (cadr form)))
  217.          (and (list? inside)
  218.               (< 0 (length inside))
  219.               (eq? sym (car inside))
  220.               (let loop ((ls (cdr inside)) (alist '()))
  221.                 (if (null? ls)
  222.                     alist               ; retval
  223.                     (let ((first (car ls)))
  224.                       (or (symbol? first)
  225.                           (error "bad list!"))
  226.                       (loop (cddr ls)
  227.                             (acons (string->symbol
  228.                                     (substring (symbol->string first) 1))
  229.                                    (cadr ls)
  230.                                    alist)))))))))
  231.  
  232. ;; Filter FORMS, combining contiguous comment forms that have the same number
  233. ;; of leading semicolons.  Do not include in them whitespace lines.
  234. ;; Whitespace lines outside of such comment groupings are ignored, as are
  235. ;; hash-bang comments.  All other forms are passed through unchanged.
  236. ;;
  237. (define (clump forms)
  238.   (let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
  239.     (if (null? forms)
  240.         (reverse acc)                   ; retval
  241.         (let ((form (car forms)))
  242.           (cond (pass-this-one-through?
  243.                  (loop (cdr forms) (cons form acc) #f))
  244.                 ((quoted? 'following-form-properties form)
  245.                  (loop (cdr forms) (cons form acc) #t))
  246.                 ((quoted? 'whitespace form)             ;;; ignore
  247.                  (loop (cdr forms) acc #f))
  248.                 ((quoted? 'hash-bang-comment form)      ;;; ignore for now
  249.                  (loop (cdr forms) acc #f))
  250.                 ((quoted? 'comment form)
  251.                  => (lambda (alist)
  252.                       (let cloop ((inner-forms (cdr forms))
  253.                                   (level (assq-ref alist 'leading-semicolons))
  254.                                   (text (list (assq-ref alist 'text))))
  255.                         (let ((up (lambda ()
  256.                                     (loop inner-forms
  257.                                           (cons (cons level (reverse text))
  258.                                                 acc)
  259.                                           #f))))
  260.                           (if (null? inner-forms)
  261.                               (up)
  262.                               (let ((inner-form (car inner-forms)))
  263.                                 (cond ((quoted? 'comment inner-form)
  264.                                        => (lambda (inner-alist)
  265.                                             (let ((new-level
  266.                                                    (assq-ref
  267.                                                     inner-alist
  268.                                                     'leading-semicolons)))
  269.                                               (if (= new-level level)
  270.                                                   (cloop (cdr inner-forms)
  271.                                                          level
  272.                                                          (cons (assq-ref
  273.                                                                 inner-alist
  274.                                                                 'text)
  275.                                                                text))
  276.                                                   (up)))))
  277.                                       (else (up)))))))))
  278.                 (else (loop (cdr forms) (cons form acc) #f)))))))
  279.  
  280. ;;; script entry point
  281.  
  282. (define main read-scheme-source)
  283.  
  284. ;;; read-scheme-source ends here
  285.